(*
 *  MTASC - MotionTwin ActionScript2 Compiler
 *  Copyright (c)2004 Nicolas Cannasse
 *
 *  This program is free software; you can redistribute it and/or modify
 *  it under the terms of the GNU General Public License as published by
 *  the Free Software Foundation; either ocamlc -I ../swflib/ -I ../extlib-dev/ -c genSwfGeneratorTools.ml
  2 of the License, or
 *  (at your option) any later version.
 *
 *  This program is distributed in the hope that it will be useful,
 *  but WITHOUT ANY WARRANTY; without even the implied warranty of
 *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 *  GNU General Public License for more details.
 *
 *  You should have received a copy of the GNU General Public License
 *  along with this program; if not, write to the Free Software
 *  Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 *)

open Expr
open Swf
open ExtHashtbl
open ExtString
open ExtList
open GenSwfTools

let version = ref None;;

let func ctx args constructor arguments =
	let default_flags = ThisRegister :: (if arguments then [] else [ArgumentsNoVar]) in
	let f = {
		f2_name = "";
		f2_args = args;
		f2_codelen = 0;
		f2_nregs = 0;
		f2_flags = (if constructor then SuperRegister :: default_flags else SuperNoVar :: default_flags);
	} in
	write ctx (AFunction2 f);
	let start_pos = ctx.code_pos in
	(fun nregs ->
		let delta = ctx.code_pos - start_pos in
		f.f2_codelen <- delta;
		f.f2_nregs <- nregs
	)
	
let super_binding_ident path fname =
	(match fst path with
	| [] -> ""
	| l -> String.concat "_" l ^ "_") ^ snd path ^ "_" ^ fname	

let unescape_chars s p = 
	let b = Buffer.create 0 in
	let rec loop esc i =
		if i = String.length s then
			()
		else
			let c = s.[i] in
			if esc then begin
				let inext = ref (i + 1) in
				(match c with
				| 'b' -> Buffer.add_char b '\b'
				| 'f' -> Buffer.add_char b (char_of_int 12)
				| 'n' -> Buffer.add_char b '\n'
				| 'r' -> Buffer.add_char b '\r'
				| 't' -> Buffer.add_char b '\t'
				| '"' | '\'' | '\\' -> Buffer.add_char b c
				| '0'..'3' ->
					let c = (try
						char_of_int (int_of_string ("0o" ^ String.sub s i 3))
					with _ ->
						raise (Lexer.Error (Lexer.Invalid_character c,p))
					) in
					Buffer.add_char b c;
					inext := !inext + 2;
				| 'x' ->
					let c = (try
						char_of_int (int_of_string ("0x" ^ String.sub s (i+1) 2))
					with _ ->
						raise (Lexer.Error (Lexer.Invalid_character c,p))
					) in
					Buffer.add_char b c;
					inext := !inext + 2;
				| 'u' ->
					let i = (try
						int_of_string ("0x" ^ String.sub s (i+1) 4)
					with _ ->
						raise (Lexer.Error (Lexer.Invalid_character c,p))
					) in
					let ub = UTF8.Buf.create 0 in
					UTF8.Buf.add_char ub (UChar.chr i);
					Buffer.add_string b (UTF8.Buf.contents ub);
					inext := !inext + 4
				| _ -> raise (Lexer.Error (Lexer.Invalid_character c,p)));
				loop false !inext;
			end else
				match c with
				| '\\' -> loop true (i + 1)
				| c ->
					Buffer.add_char b c;
					loop false (i + 1)
	in
	loop false 0;
	Buffer.contents b			

let rec generate_constant ctx p = function
	| Int str -> (try push ctx [VInt32 (Int32.of_string str)] with _ -> generate_constant ctx p (Float str))
	| Float str -> push ctx [VFloat (try float_of_string str with _ -> error p)]
	| String s -> push ctx [VStr (unescape_chars s p)]
	| Ident s -> assert false

let generate_breaks ctx olds =
	List.iter (fun f -> f()) ctx.breaks;
	ctx.breaks <- olds

let generate_function_ref = ref (fun _ _ -> assert false)

let generate_package ?(fast=false) ctx l =
	let fast = fast && (match l with
		| [] -> true
		| p :: _ -> not (Hashtbl.mem ctx.locals p)
	) in
	if fast then begin
		match l with
		| [] -> VarStr
		| p :: l ->		
			push ctx [VStr p];
			write ctx AEval;
			List.iter (fun p -> push ctx [VStr p]; write ctx AObjGet) l;
			VarObj
	end else begin
		push ctx [VStr "_global"];
		write ctx AEval;
		List.iter (fun p ->
			push ctx [VStr p];
			write ctx AObjGet;
		) l;
		VarObj
	end

let rec generate_package_register ctx = function
	| [] -> ()
	| p :: [] ->
		ignore(generate_package ~fast:true ctx (p :: []));
		write ctx ANot;
		write ctx ANot;
		let j = cjmp ctx in
		push ctx [VStr "_global"];
		write ctx AEval;
		push ctx [VStr p; VInt 0; VStr "Object"];
		write ctx ANew;
		write ctx AObjSet;
		j()
	| p :: l ->
		let lrev = List.rev l in
		let all_but_last , last = List.rev (List.tl lrev), List.hd lrev in
		generate_package_register ctx (p :: all_but_last);
		ignore(generate_package ~fast:true ctx (p :: l));
		write ctx ANot;
		write ctx ANot;
		let j = cjmp ctx in
		push ctx [VStr "_global"];
		write ctx AEval;
		List.iter (fun p -> push ctx [VStr p]; write ctx AObjGet) (p :: all_but_last);
		push ctx [VStr last; VInt 0; VStr "Object"];
		write ctx ANew;
		write ctx AObjSet;
		j()
		
let generate_ident ctx s p =
	match s with
	| "this" ->
		VarReg 1
	| "undefined" ->
		write ctx (APush [PUndefined]);
		VarReg (-1)
	| "null" ->
		push ctx [VNull];
		VarReg (-1)
	| "true" ->
		write ctx (APush [PBool true]);
		VarReg (-1)
	| "false" ->
		write ctx (APush [PBool false]);
		VarReg (-1)
	| "_global" | "_root" | "arguments" ->
		push ctx [VStr s];
		VarStr
	| "super" -> 
		assert false
	| _ ->
		try
			let l = Hashtbl.find ctx.locals s in
			if l.reg = 0 then begin
				push ctx [VStr s];
				VarStr
			end else
				VarReg l.reg
		with Not_found ->
			push ctx [VStr s];
			VarStr
			
let rec generate_access ftrace ?(forcall=false) ctx (v,p) =
	match v with		
	| EConst (Ident "super") ->
		(* for superconstructor *)
		if forcall then begin
			push ctx [VSuper];
			write ctx (APush [PUndefined]);
			VarObj
		end else
			VarReg 2
	| EConst (Ident s) ->
		generate_ident ctx s p
	| EField ((EConst (Ident "super"),_),s) when Class.is_getset ctx.current s ->
		VarGetSet s
	| EField (v,s) ->
		generate_val ftrace ctx v;
		push ctx [VStr s];
		VarObj
	| EStatic (["__With"],s) ->
		push ctx [VStr s];
		VarStr
	| EStatic (p,s) ->
		let k = generate_package ~fast:true ctx p in
		push ctx [VStr s];
		k
	| EArray (va,vb) ->
		generate_val ftrace ctx va;
		generate_val ftrace ctx vb;
		VarObj
	| _ ->
		if not forcall then error p;
		generate_val ftrace ctx (v,p);
		write ctx (APush [PUndefined]);
		VarObj

and generate_binop ftrace retval ctx op v1 v2 =
	let gen a =
		generate_val ftrace ctx v1;
		generate_val ftrace ctx v2;
		write ctx a
	in
	match op with
	| OpAssign ->
		let k = generate_access ftrace ctx v1 in
		generate_val ftrace ctx v2;
		setvar ~retval ctx k
	| OpAssignOp op ->
		let k = generate_access ftrace ctx v1 in
		generate_binop ftrace true ctx op v1 v2;
		setvar ~retval ctx k
	| OpAdd -> gen AAdd
	| OpMult -> gen AMultiply
	| OpDiv -> gen ADivide
	| OpSub -> gen ASubtract
	| OpEq -> gen AEqual
	| OpPhysEq -> gen APhysEqual
	| OpPhysNotEq ->
		gen APhysEqual;
		write ctx ANot
	| OpNotEq -> 
		gen AEqual;
		write ctx ANot
	| OpGt -> gen AGreater
	| OpGte ->
		gen ACompare;
		write ctx ANot
	| OpLt -> gen ACompare
	| OpLte ->
		gen AGreater;
		write ctx ANot
	| OpAnd -> gen AAnd
	| OpOr -> gen AOr
	| OpXor -> gen AXor
	| OpBoolAnd ->
		generate_val ftrace ctx v1;
		write ctx ADup;
		write ctx ANot;
		let jump_end = cjmp ctx in
		write ctx APop;
		generate_val ftrace ctx v2;
		jump_end()
	| OpBoolOr ->
		generate_val ftrace ctx v1;
		write ctx ADup;
		let jump_end = cjmp ctx in
		write ctx APop;
		generate_val ftrace ctx v2;
		jump_end()
	| OpShl -> gen AShl
	| OpShr -> gen AShr
	| OpUShr -> gen AAsr
	| OpMod -> gen AMod

and generate_geturl ftrace ctx c vars p =
	let k = match vars with
		| [v] when c = "getURL" ->
			generate_val ftrace ctx v;
			push ctx [VStr "_self"];
			0
		| v1 :: v2 :: l -> 
			generate_val ftrace ctx v1;
			generate_val ftrace ctx v2;
			(match l with
			| [] -> 0
			| [EConst (String "GET"),_] -> 1
			| [EConst (String "POST"),_] -> 2
			| (_,p) :: [] -> error p
			| _ -> error p)
		| _  -> error p
	in
	write ctx (AGetURL2 (k + (match c with "getURL" -> 0 | "loadMovie" -> 64 | "loadVariables" -> 192 | _ -> assert false)))

and generate_call ftrace ?(newcall=false) ctx v vl =
	match fst v , vl with
	| EConst (Ident "trace") , args ->
		(match !ftrace with
		| None ->
			(match args with
			| [v] ->
				generate_val ftrace ctx v;
				write ctx ATrace
			| _ -> error (pos v))
		| Some "" | Some "no" ->
			()
		| Some f ->
			let rec loop f =
				try
					let p , f = String.split f "." in
					let p2 , f = loop f in
					p :: p2 , f
				with
					Invalid_string -> [] , f
			in
			let p , f = loop f in
			let pos = snd v in
			let e = EStatic (p,f) , pos in
			let line = Lexer.get_error_line pos in
			generate_call ftrace ctx e 
					(args @ [
						(EConst (String (s_type_path (Class.path ctx.current) ^ "::" ^ ctx.curmethod))) , pos;
						(EConst (String (String.concat "\\\\" (String.nsplit pos.pfile "\\")))) , pos;
						(EConst (Int (string_of_int line))) , pos
					]))
	| EConst (Ident "instanceof") , [v1;v2] ->
		generate_val ftrace ctx v1;
		generate_val ftrace ctx v2;
		write ctx AInstanceOf
	| EConst (Ident "typeof") , [v] ->
		generate_val ftrace ctx v;
		write ctx ATypeOf;
	| EConst (Ident "chr") , [v] ->
		generate_val ftrace ctx v;
		write ctx AChr;
	| EConst (Ident "ord") , [v] ->
		generate_val ftrace ctx v;
		write ctx AOrd;
	| EConst (Ident "int") , [v] ->
		generate_val ftrace ctx v;
		write ctx AToInt
	| EConst (Ident "string") , [v] ->
		generate_val ftrace ctx v;
		write ctx AToString
	| EConst (Ident "random") , [v] ->
		generate_val ftrace ctx v;
		write ctx ARandom
	| EConst (Ident "delete") , [v] ->
		let v = (match v with EParenthesis v , _ -> v | _ -> v) in
		(match generate_access ftrace ctx v with
		| VarObj -> write ctx ADeleteObj
		| VarReg n when n <> -1 -> ()
		| _ -> write ctx ADelete)
	| EConst (Ident "throw") , [v] ->
		generate_val ftrace ctx v;
		write ctx AThrow
	| EConst (Ident "eval") , [v] ->
		generate_val ftrace ctx v;
		write ctx AEval
	| EConst (Ident "getTimer"), [] ->
		write ctx AGetTimer
	| EConst (Ident "targetPath") , [v] ->
		generate_val ftrace ctx v;
		write ctx ATargetPath
	| EConst (Ident "FSCommand2") , l ->
		List.iter (generate_val ftrace ctx) (List.rev l);		
		let nargs = List.length l in
		push ctx [VInt nargs];
		write ctx AFSCommand2;
		ctx.stack <- ctx.stack - nargs
	| EConst (Ident "fscommand") , [v] ->
		push ctx [VStr "FSCommand:"];
		generate_val ftrace ctx v;
		write ctx AStringAdd;
		push ctx [VStr ""];
		write ctx (AGetURL2 0)
	| EConst (Ident "fscommand") , [v1;v2] ->
		push ctx [VStr "FSCommand:"];
		generate_val ftrace ctx v1;
		write ctx AStringAdd;
		generate_val ftrace ctx v2;
		write ctx (AGetURL2 0)
	| EConst (Ident "print") , [v1;v2] ->
		let str = (match fst v2 with 
			| EConst (String "bmovie") -> "print:"
			| EConst (String "bframe") -> "print:#bframe"
			| EConst (String "bmax") -> "print:#bmax"
			| _ -> 	raise (TyperInc.Error (TyperInc.Custom "print parameter should be either bmovie, bframe or bmax",pos v2))
		) in
		push ctx [VStr str];
		generate_val ftrace ctx v1;
		write ctx (AGetURL2 0)
	| EConst (Ident ("getURL" as x)) , params
	| EConst (Ident ("loadMovie" as x)) , params
	| EConst (Ident ("loadVariables" as x)) , params ->
		generate_geturl ftrace ctx x params (pos v)
	| EField ((EConst (Ident "super"),_),fname) , args ->
		let nargs = List.length args in
		List.iter (generate_val ftrace ctx) (List.rev args);
		push ctx [VInt nargs; VSuper; VStr fname];		
		call ctx VarObj nargs;
	| EConst (Ident "getVersion") , _ ->
		push ctx [VStr "/:$version"];
		write ctx AEval;
	| EConst (Ident "stopAllSounds"), [] ->
		write ctx AStopSounds
	| _ , _ ->
		let nargs = List.length vl in
		List.iter (generate_val ftrace ctx) (List.rev vl);
		push ctx [VInt nargs];
		let k = generate_access ftrace ~forcall:true ctx v in
		if newcall then
			new_call ctx k nargs
		else
			call ctx k nargs

and generate_val ftrace ?(retval=true) ctx (v,p) =
	match v with
	| EConst (Ident _)
	| EArray _
	| EField _
	| EStatic _ ->
		let k = generate_access ftrace ctx (v,p) in
		getvar ctx k
	| EConst c ->
		generate_constant ctx p c
	| EParenthesis v ->
		generate_val ftrace ~retval ctx v
	| ECast ((EStatic ([],"String"),_),v) ->
		generate_val ftrace ctx v;
		write ctx AToString
	| ECast ((EStatic ([],"Number"),_),v) ->
		generate_val ftrace ctx v;
		write ctx AToNumber;
	| ECast ((EStatic ([],"Boolean"),_),v) ->
		generate_val ftrace ctx v;
		write ctx ANot;
		write ctx ANot;
	| ECast (_,v) when !version = Some 6 ->
		generate_val ftrace ctx v
	| ECast (v1,v2) ->
		generate_val ftrace ctx v1;
		generate_val ftrace ctx v2;
		write ctx ACast
	| EQuestion (v,v1,v2) ->
		generate_val ftrace ctx v;		
		let jump_else = cjmp ctx in
		generate_val ftrace ctx v2;
		let jump_end = jmp ctx in
		jump_else();
		generate_val ftrace ctx v1;
		jump_end();
		ctx.stack_size <- ctx.stack_size - 1;
	| EBinop (op,v1,v2) ->
		generate_binop ftrace retval ctx op v1 v2
	| ELambda f ->
		!generate_function_ref ctx f
	| ECall (v,vl) ->
		generate_call ftrace ctx v vl
	| EObjDecl fields ->
		let nfields = List.length fields in
		List.iter (fun (s,v) ->
			push ctx [VStr s];
			generate_val ftrace ctx v
		) fields;
		push ctx [VInt nfields];
		write ctx AObject;
		ctx.stack_size <- ctx.stack_size - (nfields * 2);
	| EArrayDecl vl ->
		let nfields = List.length vl in
		List.iter (generate_val ftrace ctx) (List.rev vl);
		push ctx [VInt nfields];
		write ctx AInitArray;
		ctx.stack_size <- ctx.stack_size - nfields;
	| ENew (v,args) ->
		generate_call ftrace ~newcall:true ctx v args
	| EUnop (Not,_,v) -> 
		generate_val ftrace ctx v;
		write ctx ANot
	| EUnop (Neg,x,(EConst (Int s),p2)) ->
		(try
			push ctx [VInt32 (Int32.neg (Int32.of_string s))]
		with
			_ -> generate_val ftrace ctx (EUnop (Neg,x,(EConst (Float s),p2)),p))
	| EUnop (Neg,_,(EConst (Float f),p)) ->
		push ctx [VFloat (0. -. (try float_of_string f with _ -> error p))]
	| EUnop (Neg,_,v) ->
		push ctx [VInt 0];
		generate_val ftrace ctx v;
		write ctx ASubtract
	| EUnop (NegBits,_,v) ->
		generate_val ftrace ctx v;
		push ctx [VInt (-1)]; 
		write ctx AXor
	| EUnop (op,flag,v) ->
		if retval && flag = Postfix then begin
			let k = generate_access ftrace ctx v in
			getvar ctx k
		end;
		ignore(generate_access ftrace ctx v);
		let k = generate_access ftrace ctx v in
		getvar ctx k;
		write ctx (match op with Increment -> AIncrement | Decrement -> ADecrement | _ -> assert false);
		setvar ~retval:(retval && flag = Prefix) ctx k